home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / copymove.swg / 0016_Copy-Move Files Anywhere.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-06-22  |  6.1 KB  |  184 lines
  1. {$A+,B-,D+,E+,F-,G+,I+,L+,N-,O-,P-,Q-,R-,S-,T-,V-,X+,Y+}
  2. {$M 16384,0,655360}
  3.  
  4. USES DOS,Crt;
  5.  
  6.    TYPE
  7.  
  8.    { Define action type MOVE or COPY }
  9.    cTYPE = (cMOVE,cCOPY);
  10.  
  11.    { Define the special structure of a DOS Disk Transfer Area (DTA) }
  12.    DTARec      =  RECORD
  13.                      Filler   :  ARRAY [1..21] OF BYTE;
  14.                      Attr     :  BYTE;
  15.                      Time     :  WORD;
  16.                      Date     :  WORD;
  17.                      Size     :  LONGINT;
  18.                      Name     :  STRING [12];
  19.                   END {DtaRec};
  20.  
  21. VAR
  22.     OK : Integer;
  23.     IP,OP : PathStr;  { input,output file names }
  24.  
  25.    FUNCTION Copier (cWhat : cTYPE; VAR orig: STRING;VAR nName: STRING) : Integer;
  26.  
  27.    { Copy or Move file through DOS if not on same disk. Retain original date,
  28.      time and size and delete the original on Move.  The beauty here is that
  29.      we can move files across different drives.  Also, we can rename file if
  30.      we choose.     If error, function returns error number }
  31.  
  32.  
  33.       CONST bufsize = $C000;            { About 48 KB - 49152 }
  34.  
  35.       TYPE
  36.        fileBuffer = ARRAY [1..bufsize] OF BYTE;
  37.  
  38.       VAR   Regs: registers;
  39.             src,dst: INTEGER;
  40.             bsize,osize: LONGINT;
  41.             buffer : ^fileBuffer;
  42.             DTABlk : DTARec;
  43.             fError : BOOLEAN;
  44.  
  45.       FUNCTION CheckError(err : Integer) : BOOLEAN;
  46.       BEGIN
  47.       CheckError := (Err <> 0);
  48.       fError     := (Err <> 0);
  49.       Copier     := err;
  50.       END;
  51.  
  52.       PROCEDURE delfile (VAR fName: STRING);
  53.  
  54.          VAR   Regs: registers;
  55.  
  56.          BEGIN
  57.             WITH Regs do BEGIN
  58.                ah := $43;             { Make file R/W for delete }
  59.                al := 1;
  60.                cx := 0;               { Normal file }
  61.                ds := Seg(fName[1]);   { fName is the fully qualified }
  62.                dx := Ofs(fName[1]);   { pathname of file, 0 terminated }
  63.                MsDos (Regs);
  64.                IF CheckError(Flags AND 1) THEN EXIT
  65.                ELSE BEGIN
  66.                   ah := $41;            { Delete file through fName }
  67.                   { ds:dx stil valid from set-attributes }
  68.                   MsDos (Regs);
  69.                   IF CheckError(Flags AND 1) THEN EXIT;
  70.                   END
  71.                END
  72.          END;
  73.  
  74.       BEGIN
  75.  
  76.          Copier := 0;  { Assume Success }
  77.          FindFirst(Orig,Anyfile,SearchRec(DTABlk));
  78.          IF CheckError(DosError) THEN EXIT;
  79.  
  80.          WITH Regs DO BEGIN
  81.             ah := $3D;                  { Open existing file }
  82.             al := 0;                    { Read-only }
  83.             ds := Seg(orig[1]);         { Original filename (from) }
  84.             dx := Ofs(orig[1]);
  85.             MsDos (Regs);
  86.             IF CheckError(Flags AND 1) THEN Exit
  87.             ELSE BEGIN
  88.                src := ax;               { Handle of the file }
  89.  
  90.                ah := $3C;               { Create a new file }
  91.                cx := 0;                 { Start as normal file }
  92.                ds := Seg(nName[1]);     { Pathname to move TO }
  93.                dx := Ofs(nName[1]);
  94.                MsDos (Regs);
  95.                IF CheckError(Flags AND 1) THEN Exit
  96.                ELSE
  97.                   dst := ax
  98.                END
  99.             END;
  100.  
  101.          osize := DTABlk.size;       { Size of file, from "findfirst" }
  102.          WHILE (osize > 0) AND NOT ferror DO BEGIN
  103.  
  104.             IF osize > bufsize THEN
  105.                bsize := bufsize        { Too big for buffer, use buffer size }
  106.             ELSE
  107.                bsize := osize;
  108.  
  109.             IF BSize > MAXAVAIL THEN BSize := MAXAVAIL;
  110.  
  111.             GETMEM (buffer, BSize);    { Grap some HEAP memory }
  112.  
  113.             WITH Regs DO BEGIN
  114.                ah := $3F;               { Read block from file }
  115.                bx := src;
  116.                cx := bsize;
  117.                ds := Seg(buffer^);
  118.                dx := Ofs(buffer^);
  119.                MsDos (Regs);
  120.                IF CheckError(Flags AND 1) THEN {}
  121.                ELSE BEGIN
  122.                   ah := $40;            { Write block to file }
  123.                   bx := dst;
  124.                   { cx and ds:dx still valid from Read }
  125.                   MsDos (Regs);
  126.                   IF CheckError(Flags AND 1) THEN {}
  127.                   ELSE IF ax < bsize THEN
  128.                      BEGIN
  129.                      CheckError(98); { disk full }
  130.                      END
  131.                   ELSE
  132.                      osize := osize - bsize
  133.                   END;
  134.                END;
  135.  
  136.             FREEMEM (buffer, BSize);   { Give back the memory }
  137.             END;
  138.  
  139.          IF NOT ferror AND (cWHAT = cMOVE) THEN
  140.          WITH Regs DO
  141.             BEGIN
  142.             ah := $57;                  { Adjust date and time of file }
  143.             al := 1;                    { Set date }
  144.             bx := dst;
  145.             cx := DTABlk.time;          { Out of the "find" }
  146.             dx := DTABlk.date;
  147.             MsDos (Regs);
  148.             CheckError(Flags AND 1);
  149.             END;
  150.  
  151.          WITH Regs DO
  152.             BEGIN
  153.             ah := $3E;                  { Close all files, even with errors! }
  154.             bx := src;
  155.             MsDos (Regs);
  156.             ferror := ferror OR ((flags AND 1) <> 0);
  157.             ah := $3E;
  158.             bx := dst;
  159.             MsDos (Regs);
  160.             ferror := ferror OR ((flags AND 1) <> 0)
  161.             END;
  162.  
  163.          IF ferror THEN EXIT            { we had an error somewhere }
  164.          ELSE WITH Regs DO
  165.             BEGIN
  166.             ah := $43;                  { Set correct attributes to new file }
  167.             al := 1;                    { Change attributes }
  168.             cx := DTABlk.attr;          { Attribute out of "find" }
  169.             ds := Seg(nName[1]);
  170.             dx := Ofs(nName[1]);
  171.             MsDos (Regs);
  172.             IF CheckError(Flags AND 1) THEN EXIT
  173.             ELSE
  174.                If (cWHAT = cMOVE) THEN DelFile (orig) { Now delete the original }
  175.             END                                       { if we are moving file }
  176.       END;
  177.  
  178. BEGIN
  179. clrscr;
  180. IP := 'queen1.PAS';
  181. OP := 'd:\temp\queen1.pas';
  182. OK := Copier(cCOPY,IP,OP);
  183. WriteLn(OK);
  184. END.